home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / runtime / Cprim.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-02-09  |  12.6 KB  |  538 lines
  1. /* Cprim.c
  2.  *
  3.  * (c) Copyright 1990 Carnegie Mellon University */
  4.  *
  5.  * Primitives for sml2c.  Written by David Tarditi.
  6.  */
  7.   
  8. /*
  9.    Assumptions in this file.
  10.  
  11.    (1) We are using two's complement arithmetic, where the minimum
  12.    integer is -2^31 and the maximum integer is 2^31-1 
  13.    (2) floating point numbers are represented as doubles
  14.    (3) A floating point number takes at most 8 bytes of storage
  15.    (4) values of type Cint are large enough to hold pointers
  16.    (5) arithmetic is done on integers of type Cint
  17. */
  18.  
  19. #include <math.h>
  20. #include <errno.h>
  21. #include <setjmp.h>
  22. #include "tags.h"
  23. #include "request.h"
  24. #include "cause.h"
  25. #include "ml_state.h"
  26. #include "prim.h"
  27.  
  28. /* some header files are missing this declarations */
  29.  
  30. extern int errno;
  31. extern ML_val_t overflow_e0[], sqrt_e0[], ln_e0[];
  32. extern int inML,handlerPending;
  33. extern jmp_buf top_level;
  34.  
  35. #define INT_MAX 0x7fffffff
  36. #define INT_MIN -0x80000000
  37.  
  38. /* maximum float value for floor = 2^30, minimum float value for floor
  39.    is 2^30 */
  40.  
  41. #define FLOOR_MAX 1073741824.0
  42. #define FLOOR_MIN -1073741824.0
  43. typedef int Cint;
  44. typedef double Creal;
  45. #define CREAL_SIZE 8
  46.  
  47. #define CRA 
  48.  
  49. #define NUMREGS 32
  50. #ifdef CRA
  51.  
  52. #define LIMIT_PTR_REG 2
  53. #define STORE_PTR_REG 3
  54. #define EXN_PTR_REG 5
  55. #define PC_REG 6
  56. #define STANDARD_CLOSURE_REG 7
  57. #define STANDARD_ARG_REG 8
  58. #define STANDARD_CONT_REG 9
  59.  
  60. #define LIMIT_PTR ((Cint *)Csp[LIMIT_PTR_REG])
  61. #define STORE_PTR (Csp[STORE_PTR_REG])
  62. #define DATA_PTR  R4
  63. #define EXN_PTR   (Csp[EXN_PTR_REG])
  64. #define PC (Csp[PC_REG])
  65. #define STANDARD_CLOSURE (Csp[STANDARD_CLOSURE_REG])
  66. #define STANDARD_ARG (Csp[STANDARD_ARG_REG])
  67. #define STANDARD_CONT (Csp[STANDARD_CONT_REG])
  68.  
  69. #else
  70.  
  71. #define LIMIT_PTR R2
  72. #define STORE_PTR R3
  73. #define DATA_PTR R4
  74. #define EXN_PTR R5
  75. #define PC R6
  76. #define STANDARD_CLOSURE R7
  77. #define STANDARD_ARG  R8
  78. #define STANDARD_CONT R9
  79.  
  80. #endif
  81.  
  82. /* register descriptor for functions using the standard calling
  83.    convention */
  84.  
  85. #define STDGCMASK 7
  86. #define CLOSURE(name,func_name) int name[2] = { MAKE_DESC(1,tag_record), (int) func_name};
  87.  
  88. #define RAISE(x) \
  89. { MLState->ml_allocptr = (int) DATA_PTR; \
  90.   MLState->ml_storeptr = (int) STORE_PTR; \
  91.   MLState->ml_roots[CONT_INDX] = (ML_val_t) EXN_PTR; \
  92.   MLState->ml_roots[ARG_INDX] = (ML_val_t) (x); \
  93.   MLState->ml_roots[PC_INDX] = (ML_val_t) (*(int*)EXN_PTR); \
  94.   request = REQ_RUN; \
  95.  longjmp(top_level,1); }
  96.  
  97.  
  98. #ifdef CRA
  99. Cint Csp[NUMREGS],*R4;
  100. #else
  101. Cint R0, R1, *R2, R3, *R4, R5, R6, R7, R8, R9, R10, R11, R12, R13,
  102.       R14, R15, R16, R17, R18, R19, R20, R21, R22, R23, R24, R25,
  103.       R26, R27, R28, R29, R30, R31;
  104. #endif
  105.  
  106. Cint *plimit;
  107. unsigned int Cmask;
  108.  
  109. Cint sig_return_v_function()
  110. { request = REQ_SIG_RETURN;
  111.   quicksave();
  112. }
  113.  
  114. Cint sigh_resume()
  115. { request = REQ_SIG_RESUME;
  116.   quicksave();
  117. }
  118.  
  119. Cint handle_c_function()
  120. { request = REQ_EXN;
  121.   quicksave();
  122. }
  123.  
  124. Cint return_c_function()
  125. { request = REQ_RETURN;
  126.    quicksave();
  127. }
  128.  
  129. Cint callc_v_function()
  130. { l0: if (DATA_PTR <= plimit)
  131.          { request = REQ_CALLC; quicksave(); }
  132.   invoke_gc(STDGCMASK,callc_v_function);
  133.   goto l0;
  134. }
  135.  
  136. Cint quicksave()
  137. { register MLState_t *msp = MLState;
  138.   register Cint *csp=Csp;
  139.   inML = 0;
  140.   msp->ml_allocptr = (int) DATA_PTR;
  141.   msp->ml_storeptr = (int) csp[STORE_PTR_REG];
  142.   msp->ml_roots[EXN_INDX] = (ML_val_t) csp[EXN_PTR_REG];
  143.   msp->ml_roots[CONT_INDX] = (ML_val_t) csp[STANDARD_CONT_REG];
  144.   msp->ml_roots[ARG_INDX] = (ML_val_t) csp[STANDARD_ARG_REG];
  145.   longjmp(top_level,1);
  146.  
  147.  /* should never reach here */
  148.  
  149.  die("quicksave: should never reach this point!\n");
  150.  
  151. }
  152.  
  153. #ifdef CRA
  154.  
  155. static void moveregs()
  156. { register Cint *csp = Csp;
  157.   register Cint *s = csp+NUMREGS;
  158.   register MLState_t *msp = MLState;
  159.   register ML_val_t *roots = msp->ml_roots;
  160.   msp->ml_allocptr = (int) DATA_PTR;
  161.   msp->ml_limitptr = (int) csp[LIMIT_PTR_REG];
  162.   msp->ml_storeptr = (int) csp[STORE_PTR_REG];
  163.   for (csp += 5; csp < s; *roots++ = (ML_val_t) *csp++);
  164. }
  165.  
  166. static void fetchregs()
  167. { register Cint *csp = Csp;
  168.   register Cint *s = csp+NUMREGS;
  169.   register MLState_t *msp = MLState;
  170.   register ML_val_t *roots = msp->ml_roots;
  171.   register Cint limit = msp->ml_limitptr;
  172.   DATA_PTR = (Cint *) msp->ml_allocptr;
  173.   csp[LIMIT_PTR_REG] = limit;
  174.   plimit = (Cint *) limit;
  175.   csp[STORE_PTR_REG] = (Cint) msp->ml_storeptr;
  176.   for (csp += 5; csp < s; *csp++ = (Cint) *roots++);
  177. }
  178.  
  179. #else
  180.  
  181. /* macros assume that msp is a pointer to the ML state vector */
  182.  
  183. #define SAVE(a,b) msp->ml_roots[(a)] = (ML_val_t) (b);
  184. #define RESTORE(a,b) (b) = (Cint) (msp->ml_roots[(a)]);
  185.  
  186. /* moveregs: move C registers to MLState vector */
  187.  
  188. static void moveregs()
  189. { register MLState_t *msp = MLState;
  190.   msp->ml_allocptr = (int) DATA_PTR;
  191.   msp->ml_limitptr = (int) LIMIT_PTR;
  192.   msp->ml_storeptr = STORE_PTR;
  193.   SAVE(PC_INDX,PC);
  194.   SAVE(EXN_INDX,EXN_PTR);
  195.   SAVE(CLOSURE_INDX,STANDARD_CLOSURE);
  196.   SAVE(ARG_INDX,STANDARD_ARG);
  197.   SAVE(CONT_INDX,STANDARD_CONT);
  198.   SAVE(5, R10);
  199.   SAVE(6, R11);
  200.   SAVE(7, R12);
  201.   SAVE(8, R13);
  202.   SAVE(9, R14);
  203.   SAVE(10, R15);
  204.   SAVE(11, R16);
  205.   SAVE(12, R17);
  206.   SAVE(13, R18);
  207.   SAVE(14, R19);
  208.   SAVE(15, R20);
  209.   SAVE(16, R21);
  210.   SAVE(17, R22);
  211.   SAVE(18, R23);
  212.   SAVE(19, R24);
  213.   SAVE(20, R25);
  214.   SAVE(21, R26);
  215.   SAVE(22, R27);
  216.   SAVE(23, R28);
  217.   SAVE(24, R29);
  218.   SAVE(25, R30);
  219.   SAVE(26, R31);
  220. }
  221.  
  222. /* fetchregs: fetch C registers from MLState vector */
  223. v
  224. static void fetchregs()
  225. { register MLState_t *msp = MLState;
  226.   DATA_PTR = (Cint *) msp->ml_allocptr;
  227.   LIMIT_PTR = (Cint *) msp->ml_limitptr;
  228.   plimit = (Cint *) LIMIT_PTR;
  229.   STORE_PTR = msp->ml_storeptr;
  230.   RESTORE(EXN_INDX,EXN_PTR);
  231.   RESTORE(PC_INDX,PC);
  232.   RESTORE(CLOSURE_INDX,STANDARD_CLOSURE);
  233.   RESTORE(ARG_INDX,STANDARD_ARG);
  234.   RESTORE(CONT_INDX,STANDARD_CONT);
  235.   RESTORE(5, R10);
  236.   RESTORE(6, R11);
  237.   RESTORE(7, R12);
  238.   RESTORE(8, R13);
  239.   RESTORE(9, R14);
  240.   RESTORE(10, R15);
  241.   RESTORE(11, R16);
  242.   RESTORE(12, R17);
  243.   RESTORE(13, R18);
  244.   RESTORE(14, R19);
  245.   RESTORE(15, R20);
  246.   RESTORE(16, R21);
  247.   RESTORE(17, R22);
  248.   RESTORE(18, R23);
  249.   RESTORE(19, R24);
  250.   RESTORE(20, R25);
  251.   RESTORE(21, R26);
  252.   RESTORE(22, R27);
  253.   RESTORE(23, R28);
  254.   RESTORE(24, R29);
  255.   RESTORE(25, R30);
  256.   RESTORE(26, R31);
  257. }
  258. #endif
  259.  
  260. void saveregs()
  261. {
  262.  inML = 0;
  263.  moveregs();
  264.  longjmp(top_level,1);
  265.  
  266.  /* should never reach here */
  267.  
  268.  die("saveregs: should never reach this point!\n");
  269. }
  270.  
  271. void restoreregs()
  272. { extern int NumPendingSigs, maskSignals,inSigHandler,handlerPending;
  273.   register Cint (*next)();
  274. #ifdef CDEBUG
  275.  register Cint (*prev)(),(*tmp)();
  276. #endif
  277.  
  278.   fetchregs(); 
  279.   next = (Cint (*)()) PC;
  280.  
  281.  if (NumPendingSigs && !maskSignals && !inSigHandler) {
  282.        handlerPending = 1;
  283.        plimit = (Cint *) 0;
  284.   }
  285.  
  286.  inML = 1;
  287. loop:
  288. #ifdef CDEBUG
  289.       tmp = (Cint  (*)()) ((*next)());
  290.       prev = next;
  291.       next = tmp;
  292.       goto loop;
  293. #else
  294.    next = (Cint (*)()) ((*next)());
  295.    next = (Cint (*)()) ((*next)());
  296.    next = (Cint (*)()) ((*next)());
  297.    next = (Cint (*)()) ((*next)());
  298.    next = (Cint (*)()) ((*next)());
  299.    next = (Cint (*)()) ((*next)());
  300.    next = (Cint (*)()) ((*next)());
  301.    next = (Cint (*)()) ((*next)());
  302.    next = (Cint (*)()) ((*next)());
  303.    goto loop;
  304. #endif
  305. }
  306.  
  307. int invoke_gc(mask,func)
  308. unsigned int mask;
  309. { inML = 0;
  310.   if (handlerPending) {
  311.     sig_setup();
  312.     PC = func;
  313.     Cmask = mask;
  314.     saveregs();
  315.   }
  316.   moveregs();
  317.   callgc0(CAUSE_GC,mask);
  318.   fetchregs();
  319.   inML = 1;
  320. }
  321.  
  322. int inlined_gc(mask)
  323. unsigned int mask;
  324. { inML = 0;
  325.   moveregs();
  326.   callgc0(CAUSE_GC,mask);
  327.   fetchregs();
  328.   inML = 1;
  329. }
  330.  
  331. #define ALLOC(v) (*DATA_PTR++) = ((int) (v))
  332. #define UNTAG(v) ((v) >> 1)
  333.  
  334. Cint array_v_function()
  335. { register Cint *start, *finish, initial_value;
  336.   register Cint l = UNTAG( *((Cint *) STANDARD_ARG));
  337.   register Cint newtag = (l << width_tags) | tag_array;
  338. l0:  if (l+DATA_PTR < plimit)
  339.        { initial_value = *(((Cint *) STANDARD_ARG) + 1);
  340.          ALLOC(newtag);
  341.          STANDARD_ARG = (Cint) DATA_PTR;
  342.          for (start = DATA_PTR, finish = start + l; start < finish;
  343.             *start++ = initial_value);
  344.          DATA_PTR = finish;
  345.          return( *((Cint *) STANDARD_CONT));
  346.        }
  347.   invoke_gc(STDGCMASK,array_v_function);
  348.   goto l0;
  349. }
  350.  
  351. Cint create_s_v_function()
  352. { register Cint l = UNTAG(STANDARD_ARG);
  353.   register Cint newtag = (l << width_tags) | tag_string;
  354.  
  355.   /* # of longwords needed */
  356.  
  357.   l = (l+3) >> 2;
  358.  
  359. l0:  if (l + DATA_PTR  < plimit)
  360.       { ALLOC(newtag);
  361.         STANDARD_ARG = (Cint) DATA_PTR;
  362.         DATA_PTR += l;
  363.         return( *((Cint *) STANDARD_CONT));
  364.       }
  365.     invoke_gc(STDGCMASK,create_s_v_function); goto l0;
  366. }
  367.  
  368. Cint create_b_v_function()
  369. { register Cint l = UNTAG (STANDARD_ARG);
  370.   register Cint newtag = (l << width_tags) | tag_bytearray;
  371.  
  372.  
  373.   /* # of longwords needed */
  374.  
  375.   l = (l+3) >> 2;
  376.  
  377. l0:  if (l + DATA_PTR < plimit)
  378.       { ALLOC(newtag);
  379.          STANDARD_ARG = (Cint) DATA_PTR;
  380.          DATA_PTR += l;
  381.          return( *((Cint *) STANDARD_CONT));
  382.       }
  383.      invoke_gc(STDGCMASK,create_b_v_function);
  384.      goto l0;
  385. }     
  386.  
  387. Cint logb_v_function()
  388. { RAISE(overflow_e0+1); }
  389.  
  390. Cint scalb_v_function()
  391. { RAISE(overflow_e0+1); }
  392.  
  393. Cint floor_v_function()
  394. { register Creal d = floor(*(double *) STANDARD_ARG);
  395.   if (d< FLOOR_MIN || d>FLOOR_MAX) {
  396.                 RAISE(overflow_e0+1);
  397.     }
  398.   STANDARD_ARG = (Cint) ((Cint) d * 2 + 1) ;
  399.   return (*(Cint *) STANDARD_CONT);
  400. }
  401.  
  402. #define MATH_FUNC(f,name) \
  403. Cint name() \
  404. { register Creal d; \
  405. l0:  if (3 + DATA_PTR <= plimit) { \
  406.     d = f (* ((double *) STANDARD_ARG)); \
  407.     ALLOC(MAKE_DESC(CREAL_SIZE,tag_string)); \
  408.     STANDARD_ARG = (Cint) DATA_PTR; \
  409.     *(Creal *) DATA_PTR = d; \
  410.     DATA_PTR = (Cint *) ((char *) DATA_PTR+CREAL_SIZE); \
  411.     return (*((Cint *) STANDARD_CONT)); \
  412.   } \
  413.   invoke_gc(STDGCMASK,name); \
  414.   goto l0; \
  415. } \
  416.  
  417. /* possible portability problem here; errno isn't reset by some math functions
  418.    and edition 2 of Kernighan and Ritchie says nothing about resetting
  419.    errno.  So we're resetting it ourselves here.  This could be wrong for
  420.    other OS/local environments. */
  421.  
  422. #define MATH_FUNC_WITH_ERR(f,name,err) \
  423. Cint name() \
  424. { register Creal d; \
  425. l0:  if (3 + DATA_PTR <= plimit) { \
  426.     d = f (* ((double *) STANDARD_ARG)); \
  427.     ALLOC(MAKE_DESC(CREAL_SIZE,tag_string)); \
  428.     STANDARD_ARG = (Cint) DATA_PTR; \
  429.     *(double *) DATA_PTR = d; \
  430.     DATA_PTR = (Cint *) ((char *) DATA_PTR + CREAL_SIZE); \
  431.     if ((errno == EDOM) || (errno == ERANGE)) {errno = -1; RAISE(err); } \
  432.     return (*((Cint *) STANDARD_CONT)); \
  433.   } \
  434.   else { invoke_gc(STDGCMASK,name); goto l0; } \
  435. } \
  436.  
  437. MATH_FUNC(sin, sin_v_function)
  438. MATH_FUNC(cos,  cos_v_function)
  439. MATH_FUNC(atan, arctan_v_function)
  440.  
  441. MATH_FUNC_WITH_ERR(exp,  exp_v_function, overflow_e0+1)
  442. MATH_FUNC_WITH_ERR(log, ln_v_function, ln_e0+1)
  443. MATH_FUNC_WITH_ERR(sqrt, sqrt_v_function, sqrt_e0+1)
  444.  
  445. int startptr;
  446.  
  447. CLOSURE(sigh_return_c,sig_return_v_function)
  448. CLOSURE(handle_c,handle_c_function)
  449. CLOSURE(return_c,return_c_function)
  450. CLOSURE(callc_v,callc_v_function)
  451. CLOSURE(array_v,array_v_function)
  452. CLOSURE(create_b_v,create_b_v_function)
  453. CLOSURE(create_s_v,create_s_v_function)
  454. CLOSURE(arctan_v,arctan_v_function)
  455. CLOSURE(cos_v,cos_v_function)
  456. CLOSURE(exp_v,exp_v_function)
  457. CLOSURE(floor_v,floor_v_function)
  458. CLOSURE(ln_v,ln_v_function)
  459. CLOSURE(sin_v,sin_v_function)
  460. CLOSURE(sqrt_v,sqrt_v_function)
  461. CLOSURE(logb_v,logb_v_function)
  462. CLOSURE(scalb_v,scalb_v_function)
  463.  
  464. /* multiplication with overflow checking.
  465.    We break the operands into 16-bit parts, multiply them, and put them
  466.    back together.
  467. */
  468.  
  469. /* overflow check for unsigned integer addition, where a and b are the
  470.    msb of the operands:
  471.  
  472.         a b r | ov
  473.         ----------
  474.         0 0 0   0
  475.         0 0 1   0
  476.         0 1 0   1
  477.         0 1 1   0
  478.         1 0 0   1
  479.         1 0 1   0
  480.         1 1 0   1
  481.         1 1 1   1
  482.  
  483.     Overflow = and(a,b)|((eor(a,b)&(~r)))
  484. */
  485.  
  486. #define NO_OVERFLOW(a,b,r) (((a&b)|((a^b)&(~r)))>=0)
  487. #define WORD_SIZE 16
  488. #define LONG_WORD_SIZE 32
  489. #define POW2(x) (1<<x)
  490.  
  491. /* mult: multiply two two's complement numbers, raise exception
  492.    if an overflow occurs. */
  493.  
  494. int mult(b,d)
  495. register unsigned int b,d;
  496. { register unsigned int a,c;
  497.   register int sign = b^d;
  498.  
  499. /* break b and d into hi/lo words 
  500.  
  501.       -------------   ---------
  502.       |  a  |  b  |  |c   |  d|
  503.       -------------  ---------
  504. */
  505.  
  506.   if ((int)b<0) {b = -(int)b; }
  507.   if ((int)d<0) {d = -(int)d; }
  508.   a = b >> WORD_SIZE;
  509.   b = b & (POW2(WORD_SIZE)-1);
  510.   c = d >> WORD_SIZE;
  511.   d = d & (POW2(WORD_SIZE)-1);
  512.   if (a&c) goto overflow;
  513.   a = a*d;
  514.   c = c*b;
  515.   b = b*d;
  516.   if (a<(POW2(LONG_WORD_SIZE-WORD_SIZE)) &&
  517.       c<(POW2(LONG_WORD_SIZE-WORD_SIZE)))
  518.     { d = a+c;
  519.       if (d<(POW2(LONG_WORD_SIZE-WORD_SIZE)))
  520.           { d <<= WORD_SIZE;
  521.             a=d+b;
  522.            if NO_OVERFLOW(d,b,a)
  523.            if (sign<0)
  524.           if (a<=POW2(LONG_WORD_SIZE-1))
  525.                       return (-a);
  526.           else goto overflow;
  527.            else if (a<(POW2(LONG_WORD_SIZE-1))) return (a);
  528.       }
  529.     }
  530.  overflow:
  531. #ifdef DEBUG
  532.       printf("overflow occurred\n");
  533. #endif
  534.   inML = 0;
  535.   RAISE (overflow_e0+1)
  536. }
  537.  
  538.